home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / GMISC.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  22KB  |  925 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* gmisc - translation of setl misc.c */
  10.  
  11. #define GEN
  12.  
  13. #include "hdr.h"
  14. #include "vars.h"
  15. #include "segment.h"
  16. #include "gvars.h"
  17. #include "ops.h"
  18. #include "slot.h"
  19. #include "dbxp.h"
  20. #include "exprp.h"
  21. #include "setp.h"
  22. #include "genp.h"
  23. #include "gmainp.h"
  24. #include "segmentp.h"
  25. #include "arithp.h"
  26. #include "libp.h"
  27. #include "gutilp.h"
  28. #include "initp.h"
  29. #include "miscp.h"
  30. #include "smiscp.h"
  31. #include "gmiscp.h"
  32.  
  33. static void relay_set_add(Symbol);
  34. static int in_slot_map(Tuple, Symbol);
  35. static Tuple labelmap_def(Symbol);
  36.  
  37. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  38.  
  39. unsigned int subprog_patch_get(Symbol sym)                /*;subprog_patch_get*/
  40. {
  41.     int    i, n;
  42.  
  43.     /* search tuple SUBPROG_PATCH for symbol, return*/
  44.     n = tup_size(SUBPROG_PATCH);
  45.     for (i = 1; i <= n; i += 2) {
  46.         if ((Symbol) SUBPROG_PATCH[i] == sym)
  47.             return (unsigned int) SUBPROG_PATCH[i+1];
  48.     }
  49.     return 0; /* is this right or should there be error return?*/
  50. }
  51.  
  52. void subprog_patch_put(Symbol sym, int off)            /*;subprog_patch_put*/
  53. {
  54.     int    i, n;
  55.  
  56.     n = tup_size(SUBPROG_PATCH);
  57.     for (i = 1; i <= n; i += 2) {
  58.         if ((Symbol) SUBPROG_PATCH[i] == sym ) {
  59.             SUBPROG_PATCH[i+1] = (char *) off;
  60.             return;
  61.         }
  62.     }
  63.     /* here if need new element */
  64.     SUBPROG_PATCH = tup_exp(SUBPROG_PATCH, n+2);
  65.     SUBPROG_PATCH[n+1] = (char *) sym;
  66.     SUBPROG_PATCH[n+2] = (char *) off;
  67.     /* SUBPROG_PATCH is map as tuple: domain elements are symbols, vales
  68.      * are integers
  69.      */
  70. }
  71.  
  72. void subprog_patch_undef(Symbol sym)        /*;subprog_patch_undef*/
  73. {
  74.     int i, n, j;
  75.     n = tup_size(SUBPROG_PATCH);
  76.     for (i = 1; i <= n; i += 2) {
  77.         if ((Symbol) SUBPROG_PATCH[i] == sym) {
  78.             for (j = i+2; j <= n; j++) 
  79.                 SUBPROG_PATCH[j-2] = SUBPROG_PATCH[j];
  80.             SUBPROG_PATCH[0] = (char *) n-2; /* adjust size */
  81.             break;
  82.         }
  83.     }
  84. }
  85.  
  86. /* Miscelleanous utilities on types */
  87.  
  88. Symbol base_type(Symbol name)                /*;base_type*/
  89. {
  90.     /*
  91.      * The base-type of a type-mark is itself, unless the type-mark denotes
  92.      * a subtype.
  93.      */
  94.  
  95.     while (NATURE(name) == na_subtype && TYPE_OF(name) != name)
  96.         name = TYPE_OF(name);
  97.     return name;
  98. }
  99.  
  100. int is_discrete_type(Symbol name)                        /*;is_discrete_type*/
  101. {
  102.     Symbol    btype;
  103.  
  104.     if (cdebug2 > 3)
  105.         TO_ERRFILE("AT PROC :  is_discrete_type") ;
  106.  
  107.     if (TYPE_OF(name) != (Symbol)0) btype = root_type(name);
  108.     else return FALSE;
  109.     if (btype == symbol_integer
  110.       || btype == symbol_universal_integer
  111.       || btype == symbol_discrete_type
  112.       || btype == symbol_any) return TRUE;
  113.     if (NATURE(btype) == na_enum ) return TRUE;
  114.     return FALSE;
  115. }
  116.  
  117. int is_unconstrained(Symbol typ)                        /*;is_unconstrained*/
  118. {
  119.     Symbol    parent_type;
  120.  
  121.     switch( NATURE(typ)) {
  122.     case(na_array):
  123.         return TRUE;
  124.     case(na_record):
  125.         return has_discriminant(typ);
  126.     case(na_type):
  127.         parent_type = TYPE_OF(typ);
  128.         if (parent_type == typ)
  129.             return FALSE;
  130.         else
  131.             return is_unconstrained(parent_type);
  132.     default:
  133.         return FALSE;
  134.     }
  135. }
  136.  
  137. int not_included(Symbol small_type, Symbol large_type)        /*;not_included*/
  138. {
  139.     /*
  140.      * Checks if the bounds of small_type are (statically) out of those of
  141.      * large_type.
  142.      */
  143.  
  144.     Node    small_low_def, small_high_def, large_low_def, large_high_def;
  145.     Tuple    tup;
  146.     Const    small_low, small_high, large_low, large_high;
  147.  
  148.     if (large_type == base_type(small_type))
  149.         return FALSE;     /* even if not static in that case */
  150.  
  151.     tup = SIGNATURE(small_type);
  152.     small_low_def = (Node) tup[2];
  153.     small_high_def = (Node) tup[3];
  154.     tup = SIGNATURE(large_type);
  155.     large_low_def = (Node) tup[2];
  156.     large_high_def = (Node) tup[3];
  157.     small_low = get_ivalue(small_low_def);
  158.     small_high = get_ivalue(small_high_def);
  159.     large_low = get_ivalue(large_low_def);
  160.     large_high = get_ivalue(large_high_def);
  161.     if (small_low->const_kind == CONST_OM
  162.       || small_high->const_kind == CONST_OM
  163.       || large_low->const_kind == CONST_OM
  164.       || large_high->const_kind == CONST_OM) {
  165.         return TRUE;
  166.     }
  167.     else if (is_fixed_type(large_type) || is_float_type(large_type)) {
  168.         return const_lt(small_low, small_high)
  169.           && (const_lt(small_low, large_low)
  170.           || const_gt(small_high, large_high));
  171.     }
  172.     else {
  173.         return const_lt(small_low , small_high)
  174.           && (const_lt(small_low , large_low)
  175.           || const_gt(small_high , large_high));
  176.     }
  177. }
  178.  
  179. #ifndef BINDER
  180. void optional_qual(Symbol source_type, Symbol target_type)    /*;optional_qual*/
  181. {
  182.     Symbol    source_obj_type, target_obj_type;
  183.  
  184.     /* Generates a qual if necessary. The value is already on top of stack. */
  185.     if (target_type == base_type(source_type))
  186.         ;    /* qual never necessary here */
  187.     else if (is_access_type(target_type)) {
  188.         source_obj_type = (Symbol) designated_type(source_type);
  189.         target_obj_type = (Symbol) designated_type(target_type);
  190.         if (target_obj_type != source_obj_type 
  191.           && target_obj_type != base_type(source_obj_type)) {
  192.             if (is_array_type(target_obj_type)) {
  193.                 gen_access_qual(as_qual_index, target_obj_type);
  194.             }
  195.             else if (is_record_type(target_obj_type)) {
  196.                 gen_access_qual(as_qual_discr, target_obj_type);
  197.             }
  198.             else {     /* simple type */
  199.                 ;  /* No need to qual range */
  200.             }
  201.         }
  202.  
  203.     }
  204.     else if (is_simple_type(target_type) &&
  205.         not_included(source_type, target_type)) {
  206.         gen_s(I_QUAL_RANGE, target_type);
  207.     }
  208. }
  209. #endif
  210.  
  211. int kind_of(Symbol type_name)                                    /*;kind_of*/
  212. {
  213.     /*
  214.      * Determines the memory unit addressing mode for the given type.
  215.      * NOTE: This procedure is the point where the code generator bombs whenever
  216.      *     there is something wrong with a type declaration....
  217.      */
  218.  
  219.     int        nat, tsiz;
  220.  
  221.     type_name = root_type(type_name);
  222.  
  223. #ifdef TRACE
  224.     if (debug_flag)
  225.         gen_trace_symbol("KIND_OF", type_name);
  226. #endif
  227.  
  228.     nat = NATURE(type_name);
  229.     if (nat == na_array) {
  230.         return mu_dble;
  231.     }
  232.     else if (nat == na_record || nat == na_access) {
  233.         return mu_addr;
  234.     }
  235.     else if (nat == na_package) {
  236.         return mu_byte;
  237.     }
  238.     else if (nat == na_enum) {
  239.         return mu_word;
  240.     }
  241.     else {
  242.         tsiz = TYPE_KIND(type_name);
  243.         if (tsiz == TK_BYTE) {
  244.             return mu_byte;
  245.         }
  246.         else if (tsiz == TK_WORD) {
  247.             return mu_word;
  248.         }
  249.         else if (tsiz == TK_ADDR){
  250.             return mu_addr;
  251.         }
  252.         else if (tsiz == TK_LONG) {
  253.             return mu_long;
  254.         }
  255.         else if (tsiz == TK_XLNG) {
  256.             return mu_xlng;
  257.         }
  258.         else {
  259.             compiler_error_s("Kind_of returning omega. Type name is ",
  260.               type_name);
  261.             return mu_word; /* mu_word bogus value so can proceed */
  262.         }
  263.     }
  264. }
  265.  
  266. int length_of(Symbol type_name)                        /*;length_of*/
  267. {
  268.     /* gives the number of item in the type, assumed to be a discrete type */
  269.  
  270.     Node    low, high;
  271.     Tuple    tup;
  272.     Const    low_const, high_const;
  273.     int         bs, bi;
  274.     tup = SIGNATURE(type_name);
  275.     low = (Node) tup[2];
  276.     high = (Node) tup[3];
  277.  
  278.     low_const = get_ivalue(low);
  279.     high_const = get_ivalue(high);
  280.     if    (low_const->const_kind != CONST_OM
  281.       && high_const->const_kind != CONST_OM) {
  282.         /*   return  get_ivalue_int(high)-get_ivalue_int(low)+1; */
  283.         bi = get_ivalue_int (low);
  284.         bs = get_ivalue_int (high);
  285.         if (bi > bs)
  286.             return 0;
  287.         else
  288.             return bs - bi + 1;
  289.     }
  290.     else {
  291.         return -1;
  292.     }
  293. }
  294.  
  295. /* On symbol table */
  296.  
  297. void new_symbol(Symbol new_name, int new_nature, Symbol new_type,
  298.   Tuple new_signature, Symbol new_alias)                /*;new_symbol*/
  299. {
  300.     NATURE(new_name)    = new_nature;
  301.     TYPE_OF(new_name)    = new_type;
  302.     SIGNATURE(new_name) = new_signature;
  303.     ALIAS(new_name)    = new_alias;
  304. }
  305.  
  306. /* On addresses */
  307.  
  308. void reference_of(Symbol name)                            /*;reference_of*/
  309. {
  310.     /* The C version returns result in two globals; ref_seg?? and ref_off ?? */
  311.  
  312.     int    lrmval;
  313.  
  314. #ifdef SKIP
  315.     REFERENCE_OFFSET = 0; 
  316.     REFERENCE_SEGMENT = 0; /* for initial checkout*/
  317.     return;
  318. #endif
  319.  
  320.     if (tup_mem((char *) name , PARAMETER_SET)) {
  321.         if (!tup_mem((char *) PC(), CODE_PATCH_SET)) {
  322.             CODE_PATCH_SET = tup_with(CODE_PATCH_SET, (char *)PC());
  323.         }
  324.         /* Parameters always referenced */
  325.         /* from assemble, peep-hole OK. */
  326.         REFERENCE_SEGMENT = 0;
  327.         REFERENCE_OFFSET = local_reference_map_get(name);
  328.     }
  329.     else if (local_reference_map_defined(name)) {
  330.         REFERENCE_SEGMENT = 0;
  331.         REFERENCE_OFFSET = local_reference_map_get(name);
  332.     }
  333.     else if (S_SEGMENT(name) != -1) {
  334.         REFERENCE_SEGMENT = S_SEGMENT(name);
  335.         REFERENCE_OFFSET = S_OFFSET(name);
  336.     }
  337.     else {
  338.         lrmval  =